perm filename TEST.QU[C,JRA] blob
sn#014380 filedate 1972-11-29 generic text, type T, neo UTF8
00050 (SETQ IBASE 10.)
00100 (DE PICKIT(L N)
00200 (PROG( I J L1)
00300 (SETQ J (ADD1(LENGTH L)))
00500 L1(SETQ I 1)
00600 (SETQ L1 L)
00700 L(COND((NULL L1)(RETURN N))
00750 ((OR(EQ(CAR L1) N)
00775 (EQ(PLUS(CAR L1) I)(PLUS N J))
00800 (EQ(DIFFERENCE(CAR L1) I)(DIFFERENCE N J)))(GO AGAIN)))
00900 (SETQ L1(CDR L1))
01000 (SETQ I(ADD1 I))
01050 (GO L)
01100 AGAIN(SETQ N(ADD1 N))
01200 (COND((GREATERP N 8)(RETURN NIL)))
01300 (GO L1)
01400 ))
01500 (CDEFUN QUEEN()
01600 "AUX"((ANS NIL)(N 1) M (CONTEXT(PUSH-CONTEXT)))
01700 :L (COND((EQ(LENGTH ANS) 8)(RETURN ANS)))
01750 :LL(PRINT(LIST ANS N))
01800 (CSETQ M(PICKIT ANS N))
01900 (COND(M
01987 (ADD !"(VALUE ,M ,ANS))
02000 (CSETQ CONTEXT(PUSH-CONTEXT))
02050 (CSETQ ANS(APPEND ANS(LIST M)))
02100 (CSETQ N 1)(GO 'L)))
02200 :LLL(CSETQ CONTEXT(POP-CONTEXT))
02300 (TRY-NEXT(FETCHI !"(VALUE !>N !>ANS)))
02325 (CSETQ N(ADD1 N))
02350 (COND((GREATERP N 8)(GO 'LLL)))(GO 'LL)
02400 )
02500 (QUEEN)